(library (grid-gen vars)


(export	mk-list-vrs

        is-var?
        is-vector?
	is-float?
	is-int?
	ifvar
	comp-var
	comp-float
	comp-int
	comp-string
	comp-vector
	comp-array
	
	get-int-var
	get-float-var
	
	vec-var
	
	set-ind
	del-ind
	
	var-pool

        id-eq?
        var-eq?
           
        var-has-elements?
        var-has-name?
        var-has-ind?
        var-has-def?
        var-has-dims?
        var-type
        var-elements
        var-name
        var-id
        var-dims
        var-ind
        var-def
        replace-name
        
        var-name-suffix
        add-var-onetime
        free-vars
        
        float-array
        int-array
        string-array
)

(import (guile)
        (ice-9 threads)
        (grid-gen main)
)


(define cur_id-mtx (make-mutex))
(define cur_id 1)
(define var_ord 0)

(define last-v-n (make-hash-table))  ;; (name -> N) last suffix for var name
(define free-int-pool   (make-hash-table)) ;;  (var_id -> var)
(define free-float-pool (make-hash-table)) ;;  (var_id -> var)

(define vars (make-hash-table))     ;; (var_id -> var)
(define var-names (make-hash-table)) ;; (name -> var)
(define var-pool (lambda () vars))

(define get-id (lambda ()
  (wmt cur_id-mtx
    (let ((cid cur_id))
      (set! cur_id (+ cur_id 1))
      (list 'VAR_ID cid)
    )
  )
))

(define get-ord (lambda ()
  (wmt cur_id-mtx
    (let ((o var_ord))
      (set! var_ord (+ o 1))
      o
    )
  )
))

(define mk-list-vrs (lambda (ex)
  (cond ((is-var? ex) (ex 'var-list))
        ((list? ex)   (map mk-list-vrs ex))
        (#t ex)
  )
))

(define var-yes (lamcon 'yes))

(define comp-var (lambda (typ df)
  (letrec* ((vid (get-id))
            (ord (get-ord))
            (dims '())
            (name (if (null? df) #f (car df)))
            (def  (if (> (length df) 1) (cadr df) #f))
            (def-expand (if (> (length df) 2) (caddr df) #f))
            (suff #f)
            (ind-h (make-hash-table))
         ;   (last-ind #f)
         ;   (last-iv  #f)
            (mtx (make-mutex))
            (self (lambda (cmd . args)
                    (cond ((eq? cmd 'is-var?) var-yes)
               
                          ((eq? cmd 'type) typ)
                          ((eq? cmd 'id)  vid)
                          ((eq? cmd 'ord) ord)
                          ((eq? cmd 'name) name)
                          ((eq? cmd 'def) def)
                          ((eq? cmd 'dims) dims)
                          ((eq? cmd 'ind) '())
                          
                          ((eq? cmd 'has-ind?) #f)
                          ((eq? cmd 'def-expand?) def-expand)
                          ((eq? cmd 'has-dims?) (not (null? dims)))
            
                          ((eq? cmd 'suffix) (if suff suff ""))
                          ((eq? cmd 'name-suffix)
                           (string-append (self 'name) (self 'suffix))
                          )
                          
                          ((eq? cmd 'var-list-orig) `(,typ ,(self 'id)))
                          ((eq? cmd 'var-list) (self 'var-list-orig))

                          ((eq? cmd 'set-id!)
                           (wmt mtx (set! vid (car args)))
                          )
                          ((eq? cmd 'set-name!)
                           (wmt mtx (set! name (car args)))
                          )
                          ((eq? cmd 'set-def!)
                           (wmt mtx (set! def (car args)))
                          )
                          ((eq? cmd 'set-def-expand!)
                           (wmt mtx (set! def-expand (car args)))
                          )
                          ((eq? cmd 'set-dims!)
                           (wmt mtx (set! dims (car args)))
                          )
                          ((eq? cmd 'del-ind) self)
                          ((eq? cmd 'set-ind)
                           (letrec*
                             ((ind (car args))
                              ;(v0 (if (equal? last-ind ind)
                              ;        last-iv
                              ;        #f
                              ;    )
                              ;)
                              (v1 ;(if v0 v0 
                                    (hash-ref ind-h ind #f)
                                  ;)
                              )
                              (v2
                                (if v1
                                    v1
                                    (lambda (cmd . args)
                                      (cond ((eq? cmd 'ind) (cdr ind))
                                            ((eq? cmd 'ind-list)
                                             (mk-list-vrs ind)
                                            )
                                            ((eq? cmd 'var-list)
                                             (append (self 'var-list-orig)
                                                     (mk-list-vrs ind)
                                             )
                                            )
                                            ((eq? cmd 'has-ind?) #t)
                                            (#t (apply self (cons cmd args)))
                                      )
                                    )
                                )
                              )
                             )
                             (if (not v1) (hash-set! ind-h ind v2))
                             ;(if (not v0)
                             ;    (wmt mtx
                             ;         (begin
                             ;           (set! last-ind ind)
                             ;           (set! last-iv v2)
                             ;         )
                             ;    )
                             ;)
                             v2
                           )
                          )
                          ((eq? cmd 'set-suffix!)
                           (wmt mtx (set! suff (car args)))
                          )

                          ((eq? cmd 'add-dims)
                           (wmt mtx (set! dims (append dims (car args))))
                          )
            
                          (#t (int-err "Invalid var cmd: ~a" cmd))
                    )
                  )
            )
           )
    self
  )
))

(define comp-float (lambda df (comp-var 'FLOAT df)))
(define comp-int (lambda df (comp-var 'INT df)))

(define comp-vector (lambda elements
  (letrec* ((vec (comp-var 'VECTOR '()))
            (myid (vec 'id))
            (vars elements)
            (self (lambda (cmd . args)
              (cond ((eq? cmd 'is-array?) #t)
                    ((eq? cmd 'elements) vars)
                    
                    ((eq? cmd 'var-list-orig)
                    `(VECTOR ,(map (lambda (v) (v 'var-list)) vars))
                    )
                    
                    ((eq? cmd 'var-list-orig) (self 'var-list-orig))
                    
                    ((eq? cmd 'set-ind)
                     (let ((v1 (comp-vector)))
                       (v1 'set-id! myid)
                       (v1 'set-elements!
                           (map (lambda (v) (v 'set-ind (car args)))
                                vars
                           )
                       )
                     )
                    )
                    
                    ((eq? cmd 'vec-var)
                     (let* ((nam (car args))
                            (l (filter
                                 (lambda (v) (string-ci=? (v 'name) nam))
                                 vars
                               )
                            )
                           )
                       (if (= (length l) 1)
                           (car l)
                           (int-err "vec-var error: ~a vars found" (length l))
                       )
                     )
                    )
                    
                    ((eq? cmd 'set-elements!) (set! vars args))
                    ((eq? cmd 'set-suffix!) 
                     (for-each (lambda (v) (v 'set-suffix!) (car args))
                               vars
                     )
                    )
                    
                    ((eq? cmd 'set-dims!)
                     (begin
                       (vec 'set-dims (car args))
                       (for-each (lambda (v) (v 'set-dims! (car args))) vars)
                     )
                    )

                    ((eq? cmd 'add-dims)
                     (begin
                       (vec 'add-dims (car args))
                       (for-each (lambda (v) (v 'add-dims (car args))) vars)
                     )
                    )
                    
                    (#t (apply vec (cons cmd args)))
              )
            ))
           )
    (for-each (lambda (v) (add-id-to-var myid v)) vars)
    self
  )
))

(define comp-array (lambda (var dims)
  (add-dims (add-id-to-var (get-id) var) dims)
  var
))

(define float-array (lambda (name dims) (comp-array (comp-float name) dims)))
(define int-array (lambda (name dims) (comp-array (comp-int name) dims)))

(define is-var? (lambda (var)
  (if (procedure? var)
      (catch #t
        (lambda () (eq? (var 'is-var?) var-yes))
        (lambda (args) #f)
      )
      #f
  )
))
(define is-vector? (lambda (a) (eq? (a 'type) 'VECTOR)))
(define is-float?  (lambda (a) (eq? (a 'type) 'FLOAT)))
(define is-int?    (lambda (a) (eq? (a 'type) 'INT)))
(define id-eq? equal?)
(define var-eq? (lambda (v1 v2)
  (equal? (v1 'var-list) (v2 'var-list))
))

(define var-declared? (lambda (var) (hash-ref vars (var 'id) #f)))

(define var-elements (lambda (var)    (var 'elements)))
(define get-suffix-for (lambda (var)  (var 'suffix)))
(define var-name-suffix (lambda (var) (var 'name-suffix)))
(define var-type (lambda (var) (var 'type)))

(define var-dims (lambda (var)
  (if (var 'has-dims?)
    (var 'dims)
    (list)
  )
))

(define var-def (lambda (var)
  (let ((vd (var 'def)))
    (if vd vd (list))
  )
))

(define var-has-ind? (lambda (var) (var 'has-ind?)))
(define var-has-dims? (lambda (var) (var 'has-dims?)))
(define var-has-def? (lambda (var) (var 'def)))
(define var-has-name? (lambda (var) (var 'name)))
(define var-has-elements? (lambda (var) (is-vector? var)))

(define var-id (lambda (var)   (var 'id)))
(define var-name (lambda (var) (var 'name)))
(define var-ind (lambda (var)  (var 'ind)))
(define vec-var (lambda (var nam) (var 'vec-var nam)))


(define add-id-to-var (lambda (id var)
  (var 'set-id! (cons 'VAR_ID (append (cdr id) (cdr (var 'id)))))
  var
))

(define replace-name (lambda (var name) (var 'set-name! name)))
(define del-ind (lambda (var) (var 'del-ind)))

(define set-ind (lambda (var inds)
  (letrec ((ai (if (list? inds)
                   (cons 'VAR_IND (append inds (var 'ind)))
                   (cons 'VAR_IND (cons inds (var 'ind)))
               )
           )
          )
    (if (null? inds)
         var
         (var 'set-ind ai)
    )
  )
))

(define add-dims (lambda (var dims)
  (if (not (null? dims))
      (var 'add-dims dims)
  )
  var
))

(define-syntax ifvar
  (syntax-rules (int: float: vect:)
    ((_ v int: ei float: ef vect: ev)
     (cond ((is-int? v) ei)
           ((is-float? v) ef)
           ((is-vector? v) ev)
           (#t (int-err (format #f "Not a var: ~a\n" v)))
     )
    )
  )
)

(define free-vars (lambda (vrs)
  (for-each 
    (lambda (x)
      (cond ((is-int? x) (hash-set! free-int-pool (x 'id) x))
            ((is-float? x) 
             ;;(hash-set! free-float-pool (x 'id) x)
             #f
            )
            (#t (int-err "free-vars: Invalid var type"))
      )
    )
    vrs
  )
))

(define unused-int-name (lambda ()
  (letrec ((fnam (lambda (nam num)
             (let ((vn (string-append
                         (char-set->string (char-set nam))
                         (if (> num 0) (number->string num) "")
                       )
                   )
                  )
               (if (hash-ref var-names vn #f)
                   (fnam (if (< (char->integer nam) (char->integer #\n))
                               (integer->char (+ 1 (char->integer nam)))
                               #\i
                         )
                         (if (< (char->integer nam) (char->integer #\n))
                              num
                              (+ 1 num)
                         )
                   )
                   (begin
                     (hash-set! last-v-n (char-set->string (char-set nam)) num)
                     vn
                   )
               )
             )
           ))
          )
    (fnam #\i 0)
  )
))

(define unused-float-name (lambda ()
  (letrec ((fnam (lambda (nam num)
             (let ((vn (string-append
                         (char-set->string (char-set nam))
                         (if (> num 0) (number->string num) "")
                       )
                   )
                  )
               (if (hash-ref var-names vn #f)
                   (fnam (if (< (char->integer nam) (char->integer #\z))
                             (integer->char 
                               (+ (if (= (char->integer nam)
                                         (- (char->integer #\i) 1)
                                      )
                                      (+ (- (char->integer #\o)
                                            (char->integer #\i)
                                         )
                                         1
                                      )
                                      1
                                  )
                                  (char->integer nam)
                               )
                             )
                             #\a
                        )
                        (if (< (char->integer nam) (char->integer #\z))
                             num
                             (+ 1 num)
                        )
                   )
                   (begin
                     (hash-set! last-v-n (char-set->string (char-set nam)) num)
                     vn
                   )
               )
             )
           ))
          )
    (fnam #\a 0)
  )
))


(define add-var-onetime (lambda (var)
  (if (not (var 'name))
    (ifvar var
      int:   (var 'set-name! (unused-int-name))
      float: (var 'set-name! (unused-float-name))
      vect:  (int-err "add-var-onetime for vector")
    )
  )
  (if (not (var-declared? var))
    (letrec* ((vname (var 'name))
              (vid (var 'id))
              (add-w (lambda (suff)
                (begin
                  (var 'set-suffix! suff)
                  (hash-set! vars vid var)
                  (hash-set! var-names (var 'name-suffix) var)
                )
              ))
              (get-w-n (lambda (s)
                (let ((suff (if (> s 0) (number->string s) "")))
                  (if (hash-ref var-names (string-append vname suff) #f)
                      (get-w-n (if (= s 0)
                                   (hash-ref last-v-n vname 1)
                                   (+ s 1)
                               )
                      )
                      s
                  )
                )
              ))
             )
      (if (hash-ref var-names vname #f)
          (let* ((n (get-w-n 0)))
            (hash-set! last-v-n vname n)
            (add-w (number->string n))
          )
          (add-w "")
      )
    )
  )
  var
))

(define get-int-var (lambda ()
  (let ((vrs (hash-map->list (lambda x x) free-int-pool)))
    (if (null? vrs)
        (comp-int "i")
        (let ((kv (car vrs)))
          (hash-remove! free-int-pool (car kv))
          (cadr kv)
        )
    )
  )
))

(define get-float-var (lambda ()
  (let ((vrs (hash-map->list (lambda x x) free-float-pool)))
    (if (null? vrs)
        (comp-float "t")
        (let ((kv (car vrs)))
          (hash-remove! free-float-pool (car kv))
          (cadr kv)
        )
    )
  )
))

)
